home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / sys / unix_float.t < prev    next >
Encoding:
Text File  |  1990-01-30  |  4.4 KB  |  158 lines
  1. (herald unix_float (env tsys))
  2.  
  3. (define-integrable (make-flonum)
  4.   (make-vector-extend header/double-float 0 2 ))
  5.  
  6. (define (kludgy-string->flonum s)
  7.   (let ((n (make-flonum))
  8.         (b (get-string-buffer-of-size 50)))
  9.     (set (string-length b) 50)
  10.     (string-fill b #\space)
  11.     (string-replace b s (string-length s))
  12.     (unix-sscanf b "%F" n)
  13.     (release-string-buffer b)
  14.     n))
  15.  
  16. (define-foreign unix-sscanf ("sscanf" (in rep/string)
  17.                                (in rep/string)
  18.                                (in rep/extend))   ; pointer to double
  19.   rep/undefined)
  20.                                                
  21. (define (print-flonum-kludgily n stream)
  22.   (let ((b (get-string-buffer-of-size 50)))       
  23.     (set (string-length b) 50)
  24.     (unix-sprintf b "%e!" n)
  25.     (set (string-length b) (string-posq #\! b))
  26.     (write-string stream b)
  27.     (release-string-buffer b)
  28.     (no-value)))
  29.  
  30. (define-foreign unix-sprintf ("hack_sprintf" (in rep/string)
  31.                                  (in rep/string)
  32.                                  (in rep/extend))
  33.   rep/undefined)
  34.  
  35. (define (*define-fl-proc-1 xenoid id)
  36.   (object (lambda (x)
  37.             (xenoid (enforce double-float? x)))
  38.           ((identification self) id)))
  39.  
  40. (define (*define-fl-proc-3 xenoid id)
  41.   (object (lambda (x y)
  42.             (let ((x (enforce double-float? x))
  43.                   (y (enforce double-float? y)))
  44.               (fixnum-odd? (xenoid x y))))
  45.           ((identification self) id)))
  46.                     
  47. (define-local-syntax (define-fl-proc-1 name)
  48.   (let ((xeno-name (concatenate-symbol 'fl name)))
  49.     `(block (define-foreign ,xeno-name
  50.           (,(string-downcase! (symbol->string name)) (in rep/double))
  51.               rep/double)
  52.             (define ,name (*define-fl-proc-1 ,xeno-name ',name)))))
  53.   
  54.  
  55. (define-local-syntax (define-fl-proc-3 name)
  56.   (let* ((xeno-name (concatenate-symbol 'fl name))
  57.      (t-name (concatenate-symbol 'flonum- name '?))
  58.      (internal-t-name (concatenate-symbol '% t-name)))
  59.     `(block (define-foreign ,internal-t-name 
  60.               (,(string-downcase! (symbol->string xeno-name))
  61.            (in rep/double)
  62.            (in rep/double))
  63.               rep/integer)
  64.             (define ,t-name (*define-fl-proc-3 ,internal-t-name ',t-name)))))
  65.   
  66. (define-foreign %flonum-add ("fladd" (in rep/extend) (in rep/extend) (in rep/extend))
  67.   ignore)
  68.  
  69. (define-foreign %flonum-subtract ("flsubtract" (in rep/extend) (in rep/extend) (in rep/extend))
  70.   ignore)
  71.  
  72. (define-foreign %flonum-multiply ("flmultiply" (in rep/extend) (in rep/extend) (in rep/extend))
  73.   ignore)
  74.  
  75. (define-foreign %flonum-divide ("fldivide" (in rep/extend) (in rep/extend) (in rep/extend))
  76.   ignore)
  77.  
  78. (define (make-flonum-binop proc)
  79.   (lambda (x y)
  80.     (let ((x (enforce double-float? x))
  81.       (y (enforce double-float? y))
  82.       (z (make-flonum)))
  83.       (proc z x y)
  84.       z)))
  85.  
  86. (define flonum-add  (make-flonum-binop %flonum-add))
  87. (define flonum-subtract  (make-flonum-binop %flonum-subtract))
  88. (define flonum-multiply  (make-flonum-binop %flonum-multiply))
  89. (define flonum-divide  (make-flonum-binop %flonum-divide))
  90.  
  91. (define (fl+! x y)
  92.   (%flonum-add x x y)
  93.   x)
  94.  
  95. (define (fl-! x y)
  96.   (%flonum-subtract x x y)
  97.   x)
  98.  
  99.  
  100. (define (fl*! x y)
  101.   (%flonum-multiply x x y)
  102.   x)
  103.  
  104.  
  105. (define (fl/! x y)
  106.   (%flonum-divide x x y)
  107.   x)
  108.  
  109.  
  110. (define-fl-proc-1 sin)
  111. (define-fl-proc-1 cos)
  112. (define-fl-proc-1 tan)
  113. (define-fl-proc-1 asin)
  114. (define-fl-proc-1 acos)
  115. (define-fl-proc-1 atan)
  116. (define-fl-proc-1 exp)
  117. (define-fl-proc-1 log)
  118. (define-fl-proc-1 sqrt)
  119.  
  120.  
  121. ;;; ... also need power and atan2
  122.  
  123. (define-fl-proc-3 less)
  124. (define-fl-proc-3 equal)
  125. (define-fl-proc-3 greater)
  126.  
  127.  
  128. (define (flonum-not-equal? a b) (not (flonum-equal? a b)))
  129. (define (flonum-not-less? a b) (not (flonum-less? a b)))
  130. (define (flonum-not-greater? a b) (not (flonum-greater? a b)))
  131.                  
  132. (define-foreign float 
  133.   ("flote" (in rep/integer))   ; losing C reserved words
  134.     rep/double)
  135.  
  136. (define (fixnum->flonum fx)
  137.   (float (enforce fixnum? fx)))
  138.            
  139. (define-foreign unix-fix
  140.   ("fix" (in rep/double))
  141.     rep/integer)
  142.  
  143. (define (flonum->fixnum fl)
  144.   (unix-fix (enforce double-float? fl)))
  145.  
  146. (define-constant fl+  flonum-add)
  147. (define-constant fl-  flonum-subtract)
  148. (define-constant fl*  flonum-multiply)
  149. (define-constant fl/  flonum-divide)
  150. (define-constant fl=  flonum-equal?)
  151. (define-constant fl<  flonum-less?)
  152. (define-constant fl>  flonum-greater?)
  153. (define-constant fln= flonum-not-equal?)
  154. (define-constant fl>= flonum-not-less?)
  155. (define-constant fl<= flonum-not-greater?)
  156.  
  157.  
  158.